home *** CD-ROM | disk | FTP | other *** search
/ Aminet 24 / Aminet 24 (1998)(GTI - Schatztruhe)[!][Apr 1998].iso / Aminet / dev / lang / PPCcforth.lha / PPCcforth / nf.c < prev    next >
C/C++ Source or Header  |  1985-12-27  |  18KB  |  756 lines
  1. /* nf.c -- this program can be run to generate a new environment for the
  2.  * FORTH interpreter forth.c. It takes the dictionary from the standard input.
  3.  * Normally, this dictionary is in the file "forth.dict", so 
  4.  *    nf < forth.dict
  5.  * will do the trick.
  6.  */
  7.  
  8. #include <stdio.h>
  9. #include <ctype.h>
  10. #include "common.h"
  11. #include "forth.lex.h"        /* #defines for lexical analysis */
  12.  
  13. #define isoctal(c)    (c >= '0' && c <= '7')    /* augument ctype.h */
  14.  
  15. #define assert(c,s)    (!(c) ? failassert(s) : 1)
  16. #define chklit()    (!prev_lit ? dictwarn("Qustionable literal") : 1)
  17.  
  18. #define LINK struct linkrec
  19. #define CHAIN struct chainrec
  20.  
  21. struct chainrec {
  22.     char chaintext[32];
  23.     int defloc;                /* CFA or label loc */
  24.     int chaintype;            /* 0=undef'd, 1=absolute, 2=relative */
  25.     CHAIN *nextchain;
  26.     LINK *firstlink;
  27. };
  28.  
  29. struct linkrec {
  30.     int loc;
  31.     LINK *nextlink;
  32. };
  33.  
  34. CHAIN firstchain;
  35.  
  36. #define newchain()    (CHAIN *)(calloc(1,sizeof(CHAIN)))
  37. #define newlink()    (LINK *)(calloc(1,sizeof(LINK)))
  38.  
  39. CHAIN *find();
  40. CHAIN *lastchain();
  41. LINK *lastlink();
  42.  
  43. char *strcat();
  44. char *calloc();
  45.  
  46. int dp = DPBASE;
  47. int latest;
  48.  
  49. short mem[INITMEM];
  50.  
  51. FILE *outf, *fopen();
  52.  
  53. main(argc, argv)
  54. int argc;
  55. char *argv[];
  56. {
  57. #ifdef DEBUG
  58.     puts("Opening output file");
  59. #endif DEBUG
  60.  
  61.     strcpy(firstchain.chaintext," ** HEADER **");
  62.     firstchain.nextchain = NULL;
  63.     firstchain.firstlink = NULL;
  64.  
  65. #ifdef DEBUG
  66.     puts("call builddict");
  67. #endif DEBUG
  68.     builddict();
  69. #ifdef DEBUG
  70.     puts("Make FORTH and COLDIP");
  71. #endif DEBUG
  72.     mkrest();
  73. #ifdef DEBUG
  74.     puts("Call Buildcore");
  75. #endif DEBUG
  76.     buildcore();
  77. #ifdef DEBUG
  78.     puts("call checkdict");
  79. #endif DEBUG
  80.     checkdict();
  81. #ifdef DEBUG
  82.     puts("call writedict");
  83. #endif DEBUG
  84.     writedict();
  85.  
  86.     printf("%s: done.\n", argv[0]);
  87.     exit(0);
  88. }
  89.  
  90. buildcore()            /* set up low core */
  91. {
  92.     mem[USER_DEFAULTS+0] = INITS0;            /* initial S0 */
  93.     mem[USER_DEFAULTS+1] = INITR0;            /* initial R0 */
  94.     mem[USER_DEFAULTS+2] = TIB_START;        /* initial TIB */
  95.     mem[USER_DEFAULTS+3] = MAXWIDTH;        /* initial WIDTH */
  96.     mem[USER_DEFAULTS+4] = 0;            /* initial WARNING */
  97.     mem[USER_DEFAULTS+5] = dp;            /* initial FENCE */
  98.     mem[USER_DEFAULTS+6] = dp;            /* initial DP */
  99.     mem[USER_DEFAULTS+7] = instance("FORTH") + 3;    /* initial CONTEXT */
  100.  
  101.     mem[SAVEDIP] = 0;                /* not a saved FORTH */
  102. }
  103.  
  104. builddict()            /* read the dictionary */
  105. {
  106.     int prev_lit = 0, lit_flag = 0;
  107.     int temp;
  108.     char s[256];
  109.     TOKEN *token;
  110.  
  111.     while ((token = yylex()) != NULL) {    /* EOF returned as a null pointer */
  112. #ifdef DEBUG
  113.     printf("\ntoken: %s: %d ",token->text, token->type);
  114. #endif DEBUG
  115.     switch (token->type) {
  116.  
  117.     case PRIM:
  118. #ifdef DEBUG
  119.         printf("primitive ");
  120. #endif DEBUG
  121.         if ((token = yylex()) == NULL)    /* get the next word */
  122.         dicterr("No word following PRIM");
  123.         strcpy (s,token->text);
  124. #ifdef DEBUG
  125.         printf(".%s. ",s);
  126. #endif DEBUG
  127.         if ((token == yylex()) == NULL)    /* get the value */
  128.         dicterr("No value following PRIM <word>");
  129.         mkword(s,mkval(token));
  130.         break;
  131.  
  132.     case CONST:
  133. #ifdef DEBUG
  134.         printf("constant ");
  135. #endif DEBUG
  136.         if ((token = yylex()) == NULL)    /* get the word */
  137.         dicterr("No word following CONST");
  138.         strcpy (s,token->text);        /* s holds word */
  139. #ifdef DEBUG
  140.         printf(".%s. ",s);
  141. #endif DEBUG
  142.         if (!find("DOCON"))
  143.         dicterr ("Constant definition before DOCON: %s",s);
  144.                 /* put the CF of DOCON into this word's CF */
  145.         mkword(s,(int)mem[instance("DOCON")]);
  146.         if ((token = yylex()) == NULL)    /* get the value */
  147.         dicterr("No value following CONST <word>");
  148.         temp = mkval(token);
  149.  
  150.         /* two special-case constants */
  151.         if (strcmp(s,"FIRST") == 0) temp = INITR0;
  152.         else if (strcmp(s,"LIMIT") == 0) temp = DPBASE;
  153.  
  154.         comma(temp);
  155.         break;
  156.  
  157.     case VAR:
  158. #ifdef DEBUG
  159.         printf("variable ");
  160. #endif DEBUG
  161.         if ((token = yylex()) == NULL)    /* get the variable name */
  162.         dicterr("No word following VAR");
  163.         strcpy (s,token->text);
  164. #ifdef DEBUG
  165.         printf(".%s. ",s);
  166. #endif DEBUG
  167.         if (!find("DOVAR"))
  168.         dicterr("Variable declaration before DOVAR: %s",s);
  169.         mkword (s, (int)mem[instance("DOVAR")]);
  170.         if ((token = yylex()) == NULL)    /* get the value */
  171.         dicterr("No value following VAR <word>");
  172.         comma(mkval(token));
  173.         break;
  174.  
  175.     case USER:
  176. #ifdef DEBUG
  177.         printf("uservar ");
  178. #endif DEBUG
  179.         if ((token = yylex()) == NULL)    /* get uservar name */
  180.         dicterr("No name following USER");
  181.         strcpy (s,token->text);
  182. #ifdef DEBUG
  183.         printf(".%s. ",s);
  184. #endif DEBUG
  185.         if (!find("DOUSE"))
  186.         dicterr("User variable declared before DOUSE: %s",s);
  187.         mkword (s, (int)mem[instance("DOUSE")]);
  188.         if ((token = yylex()) == NULL)    /* get the value */
  189.         dicterr("No value following USER <word>");
  190.         comma(mkval(token));
  191.         break;
  192.  
  193.     case COLON:
  194. #ifdef DEBUG
  195.         printf("colon def'n ");
  196. #endif DEBUG
  197.         if ((token = yylex()) == NULL)    /* get name of word */
  198.         dicterr("No word following : in definition");
  199.         strcpy (s,token->text);
  200. #ifdef DEBUG
  201.         printf(".%s.\n",s);
  202. #endif DEBUG
  203.         if (!find("DOCOL"))
  204.         dicterr("Colon definition appears before DOCOL: %s",s);
  205.  
  206.         if (token->type == NUL) {    /* special zero-named word */
  207.         int here = dp;        /* new latest */
  208. #ifdef DEBUG
  209.         printf("NULL WORD AT 0x%04x\n");
  210. #endif DEBUG
  211.         comma(0xC1);
  212.         comma(0x80);
  213.         comma(latest);
  214.         latest = here;
  215.         comma((int)mem[instance("DOCOL")]);
  216.         }
  217.         else {
  218.         mkword (s, (int)mem[instance("DOCOL")]);
  219.         }
  220.         break;
  221.  
  222.     case SEMICOLON:
  223. #ifdef DEBUG
  224.         puts("end colon def'n");
  225. #endif DEBUG
  226.         comma (instance(";S"));
  227.         break;
  228.  
  229.     case SEMISTAR:
  230. #ifdef DEBUG
  231.         printf("end colon w/IMMEDIATE ");
  232. #endif DEBUG
  233.         comma (instance (";S"));    /* compile cfA of ;S, not CF */
  234.         mem[latest] |= IMMEDIATE;    /* make the word immediate */
  235.         break;
  236.  
  237.     case STRING_LIT:
  238. #ifdef DEBUG
  239.         printf("string literal ");
  240. #endif DEBUG
  241.         strcpy(s,token->text);
  242.         mkstr(s);        /* mkstr compacts the string in place */
  243. #ifdef DEBUG
  244.         printf("string=(%d) \"%s\" ",strlen(s),s);
  245. #endif DEBUG
  246.         comma(strlen(s));
  247.         {
  248.         char *stemp;
  249.         stemp = s;
  250.         while (*stemp) comma(*stemp++);
  251.         }
  252.         break;
  253.     
  254.     case COMMENT:
  255. #ifdef DEBUG
  256.         printf("comment ");
  257. #endif DEBUG
  258.         skipcomment();
  259.         break;
  260.  
  261.     case LABEL:
  262. #ifdef DEBUG
  263.         printf("label: ");
  264. #endif DEBUG
  265.         if ((token = yylex()) == NULL)
  266.         dicterr("No name following LABEL");
  267. #ifdef DEBUG
  268.         printf(".%s. ", token->text);
  269. #endif DEBUG
  270.         define(token->text,2);    /* place in sym. table w/o compiling
  271.                        anything into dictionary; 2 means
  272.                        defining a label */
  273.         break;
  274.  
  275.     case LIT:
  276.         lit_flag = 1;        /* and fall through to the rest */
  277.  
  278.     default:
  279.         if (find(token->text) != NULL) {    /* is word defined? */
  280. #ifdef DEBUG
  281.         printf("  normal: %s\n",token->text);
  282. #endif DEBUG
  283.             comma (instance (token->text));
  284.         break;
  285.         }
  286.  
  287.         /* else */
  288.         /* the literal types all call chklit(). This macro checks to
  289.            if the previous word was "LIT"; if not, it warns */
  290.         switch(token->type) {
  291.         case DECIMAL: chklit(); comma(mkdecimal(token->text)); break;
  292.         case HEX: chklit(); comma(mkhex(token->text)); break;
  293.         case OCTAL: chklit(); comma(mkoctal(token->text)); break;
  294.         case C_BS: chklit(); comma('\b'); break;
  295.         case C_FF: chklit(); comma('\f'); break;
  296.         case C_NL: chklit(); comma('\n'); break;
  297.         case C_CR: chklit(); comma('\r'); break;
  298.         case C_TAB: chklit(); comma('\t'); break;
  299.         case C_BSLASH: chklit(); comma(0x5c); break;  /* ASCII backslash */
  300.         case C_LIT: chklit(); comma(*((token->text)+1)); break;
  301.  
  302.         default:
  303. #ifdef DEBUG
  304.         printf("forward reference");
  305. #endif DEBUG
  306.         comma (instance (token->text));        /* create an instance,
  307.                         to be resolved at definition */
  308.         }
  309.     }
  310. #ifdef DEBUG
  311.     if (lit_flag) puts("expect a literal");
  312. #endif DEBUG
  313.     prev_lit = lit_flag;    /* to be used by chklit() next time */
  314.     lit_flag = 0;
  315.     }
  316. }
  317.  
  318. comma(i)            /* put at mem[dp]; increment dp */
  319. {
  320.     mem[dp++] = (unsigned short)i;
  321.     if (dp > INITMEM) dicterr("DICTIONARY OVERFLOW");
  322. }
  323.  
  324. /*
  325.  * make a word in the dictionary.  the new word will have name *s, its CF
  326.  * will contain v. Also, resolve any previously-unresolved references by
  327.  * calling define()
  328.  */
  329.  
  330. mkword(s, v)
  331. char *s;
  332. short v;
  333.